home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / WRITE._c < prev   
Text File  |  1990-06-26  |  11KB  |  406 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "files.h"
  22. #include "maxvars.h"
  23.  
  24. /*
  25. WriteOut writes a term to the text file 'output', using operator
  26. information in atom entries to select the best syntax.  
  27. */
  28.  
  29. IMPORT boolean TRACING,SPYTRACE;
  30. IMPORT int SPYING;
  31. IMPORT ENV E;
  32. IMPORT PREC LPREC(),RPREC();
  33. IMPORT void ABORT(),SYSTEMERROR(); 
  34. IMPORT void GETCHAR(); 
  35. IMPORT char CH; 
  36. IMPORT TERM phy_name();
  37. IMPORT boolean FILEENDED();
  38. IMPORT file OpenFile();
  39. IMPORT boolean UserAbort,ENAB_INTR;
  40.  
  41.  
  42. #if !BIT8
  43. #define WRITEDEPTH 200   /* Max. nesting depth */
  44. #endif
  45. #if BIT8
  46. #define WRITEDEPTH 20   /* Max. nesting depth */
  47. #endif
  48.  
  49. #define WRITELENGTH 512   /* Max. list length */
  50.  
  51. FORWARD void wq();
  52.  
  53. IMPORT TERM VAR_TAB[MAXVARS]; /* use vartable from read.c */
  54.  
  55. LOCAL int  VARCNT;
  56. LOCAL boolean LISTFLAG,DISPLFLAG,QUOTE;
  57.  
  58. IMPORT char CHARCLASS[]; /* from readin.c */
  59.  
  60. #define SC 1
  61. #define BC 2
  62. #define DC 3
  63. #define OC 4
  64. #define C0 5
  65.  
  66. LOCAL boolean last_was_numb;
  67.  
  68. LOCAL void WRITETERM (TERM Y, PREC P, int DEPTH)
  69. { 
  70.     ATOM A;
  71.     last_was_numb=false;
  72.     if(UserAbort && ENAB_INTR) return;
  73.     if(DEPTH <=0)  { ws("___"); return; }
  74.     /* if(!LISTFLAG) deref(Y); */
  75.     if(!LISTFLAG || name(Y)==VART) deref(Y);
  76.     switch (A=name(Y))
  77.     {
  78.     case INTT: wi(ival(Y)); last_was_numb=true; break;
  79. #if LONGARITH
  80.     case LONGT: ws(ltoa(longval(Y))); last_was_numb=true; break;
  81. #endif
  82. #if REALARITH
  83.     case REALT: ws(ftoa(realval(Y))); last_was_numb=true; break;
  84. #endif
  85.     case UNBOUNDT:
  86.       if(is_heapterm(Y))
  87.       ws("_");
  88.       else
  89.       {
  90.           int D;
  91.           ws("_");
  92.           D=0;
  93.           while(D!=VARCNT)
  94.               if(Y==VAR_TAB[D++]) { wi(D); return; }
  95.           if(VARCNT!=MAXVARS)
  96.               { VAR_TAB[VARCNT++]=Y; wi(VARCNT); }
  97.       }
  98.       break;
  99.  
  100.     case SKELT:
  101.       ws("_"); wi(offset(Y)); break;
  102.  
  103.     case CURLY_1:
  104.       ws("{"); WRITETERM(son(Y),MAXPREC,DEPTH-1); 
  105.       if(UserAbort && ENAB_INTR) return;
  106.       ws("}"); break;
  107.  
  108.     case CONS_2:
  109.       if(!DISPLFLAG)
  110.         { int  N;
  111.           TERM  Z,ZZ;
  112.           boolean asciistring=true;
  113.           Z=Y; N=0;
  114.           do { N++;
  115.                if(LISTFLAG) ZZ=son(Z); else ZZ=arg1(Z);
  116.                if(name(ZZ)!=INTT || ival(ZZ)<' ' || 127<=ival(ZZ)) 
  117.                asciistring=false; 
  118.                if(LISTFLAG) Z=br(son(Z)); else Z=arg2(Z);
  119.           } while(name(Z)==CONS_2 && N < WRITELENGTH); 
  120.           if(N >=WRITELENGTH)goto listnotation;
  121.           if(name(Z)!=NIL_0) 
  122.           { asciistring=false;
  123.             if(name(Z)!=UNBOUNDT && name(Z)!=SKELT) goto operator;  
  124.             /* operator representation  a.b.c  for 
  125.                not well founded lists */
  126.           }
  127.           if(asciistring && 0<N && N<60)
  128.           { ws("\""); 
  129.             Z=Y; 
  130.             do { if(LISTFLAG) ZZ=son(Z); else ZZ=arg1(Z);
  131.                  wc(ival(ZZ));
  132.                  if(LISTFLAG) Z=br(son(Z)); else Z=arg2(Z);
  133.             } while(name(Z)==CONS_2);
  134.             ws("\"");
  135.             break;
  136.           }
  137.         listnotation:
  138.           ws("[");
  139.           WRITETERM(son(Y),SUBPREC,DEPTH-1);
  140.           if(UserAbort && ENAB_INTR) return;
  141.           N=1;
  142.           if(LISTFLAG) Z=br(son(Y)); else Z=arg2(Y);
  143.           while(N++!=WRITELENGTH && name(Z)==CONS_2 )
  144.           { ws(", ");
  145.             WRITETERM(son(Z),SUBPREC,DEPTH-1);
  146.             if(UserAbort && ENAB_INTR) return;
  147.             if(LISTFLAG) Z=br(son(Z)); else Z=arg2(Z);
  148.           }
  149.           if(name(Z)!=NIL_0)
  150.           { if(N<WRITELENGTH) { ws(" | "); WRITETERM(Z,SUBPREC,DEPTH-1); }
  151.             else ws(" ...");
  152.           }
  153.           ws("]");
  154.           break;
  155.         }
  156.              
  157.  
  158.     default:
  159.  
  160.       if(arity(A)==0) 
  161.       {     if(A !=NIL_0 && A !=CURLY_0 && A !=CUT_0) wq(A); 
  162.             else ws(tempcopy(A));
  163.             break;
  164.       }
  165.  
  166.   
  167.       if(oclass(A)==NONO || arity(A)>2 || DISPLFLAG) 
  168.       /*------------------------------------*/
  169.       { int i,aar;
  170.         TERM  S;
  171.         wq(A);
  172.         ws("(");  
  173.         aar=arity(A);
  174.         S=son(Y);
  175.         for(i=1;i<=aar;i++)
  176.         {  WRITETERM(S,SUBPREC,DEPTH-1);
  177.             if(UserAbort && ENAB_INTR) return;
  178.            next_br(S);
  179.            if(i < aar) ws(",");
  180.         }
  181.         ws(")");  
  182.         break;
  183.       }
  184.       
  185.       /* operator notation */
  186.       /*-------------------*/
  187.       operator:
  188.       if(P<oprec(A)) ws("(");
  189.       switch (oclass(A)) 
  190.       { case FXO: case FYO:
  191.           wq(A); ws(" "); WRITETERM(son(Y),RPREC(A),DEPTH-1); break;
  192.         case XFO: case YFO:
  193.           WRITETERM(son(Y),LPREC(A),DEPTH-1); if(UserAbort && ENAB_INTR) return;
  194.           ws(" "); wq(A); break;
  195.         case XFXO: case XFYO: case YFXO:
  196.           WRITETERM(son(Y),LPREC(A),DEPTH-1);
  197.             if(UserAbort && ENAB_INTR) return;
  198.           if(A==CONS_2 && last_was_numb) ws(" ");
  199.           else if(A!=COMMA_2 && A!=SEMI_2 && A!=COLON_2) ws(" ");  
  200.           ws(tempcopy(A));
  201.           if(A!=CONS_2 && A!=NL_2) ws(" ");  
  202.           WRITETERM(br(son(Y)),RPREC(A),DEPTH-1);
  203.             if(UserAbort && ENAB_INTR) return;
  204.           break;
  205.        default: SYSTEMERROR("WRITETERM.1");
  206.       }
  207.       if(P<oprec(A)) ws(")");
  208.       break;
  209.  
  210.   }
  211. }
  212.  
  213. GLOBAL void DISPLAY(TERM T)
  214. { QUOTE=true; LISTFLAG=false; VARCNT=0; DISPLFLAG=true;
  215. #if !CPM
  216.   out_buffer(BUF_ON);
  217. #endif
  218.   WRITETERM(T,MAXPREC,WRITEDEPTH);
  219. #if !CPM
  220.   out_buffer(BUF_OFF);
  221. #endif
  222.   QUOTE=false;
  223. }
  224.  
  225. GLOBAL void WRITEOUT(TERM X, boolean quote)
  226. { QUOTE=quote; DISPLFLAG=false; LISTFLAG=false; 
  227.   VARCNT=0; 
  228. #if !CPM
  229. /*  out_buffer(BUF_ON); */
  230. #endif
  231.   WRITETERM(X,MAXPREC,WRITEDEPTH); 
  232. #if !CPM
  233. /*  out_buffer(BUF_OFF); */
  234. #endif
  235.   QUOTE=false;
  236. }
  237.  
  238. GLOBAL void ABORT_WRITE(register TERM T)
  239. {
  240.     QUOTE=false; DISPLFLAG=false; LISTFLAG=false; 
  241.     VARCNT=0; WRITETERM(T,MAXPREC,10); 
  242. }
  243.     
  244.  
  245. GLOBAL void LISTOUT (TERM X)
  246. { LISTFLAG=true; DISPLFLAG=false;
  247.   QUOTE=true; VARCNT=0; 
  248. #if !CPM
  249.   out_buffer(BUF_ON); 
  250. #endif
  251.   WRITETERM(X,SUBPREC,WRITEDEPTH); 
  252. #if !CPM
  253.   out_buffer(BUF_OFF); 
  254. #endif
  255.   QUOTE=false;
  256. }
  257.  
  258.  
  259. /* Output a trace message. */
  260.  
  261. GLOBAL ENV TRACE_GOON=0;
  262.  
  263. GLOBAL boolean TRACE(ATOM MESS, TERM Y, ENV ENVP)
  264. { boolean spyflag=false, answer=true;
  265.   boolean mustread=true;
  266.   boolean again=false;
  267.   TERM oldinfile,oldoutfile;
  268.   boolean newgo=false;
  269.  
  270.   E=ENVP; BE=base(ENVP);
  271.   if(TRACE_GOON && E>TRACE_GOON) return true;
  272.   if(TRACE_GOON && E==TRACE_GOON && MESS==REDO_0) return true;
  273.   deref(Y);
  274. #if  DEBUG
  275.   if(DEBUGFLAG) out_1(itoa(Y));
  276.   else 
  277. #endif
  278.   if(name(Y)==COMMA_2 || name(Y)==SEMI_2 || 
  279.       name(Y)==GOTO_1 || name(Y) <=NORMATOM ||
  280.       repchar(longstring(name(Y)))=='$') 
  281.       return true; 
  282.   TRACE_GOON=0;
  283.   /* Don't trace evaluable predicates unless debugging interpreter. */
  284.      if(!(spyflag=spy(name(Y))) && !TRACING)return true;
  285.  
  286.   oldinfile=FNAME(inputfile);
  287.   inputfile=OpenFile(phy_name(STDTRACE_0),read_mode);
  288.   oldoutfile=FNAME(outputfile);
  289.   outputfile=OpenFile(phy_name(STDTRACE_0),write_mode);
  290.      ws(spyflag ? "*" : " ");
  291.      ws("("); wi((int)E); ws(")"); 
  292.      switch(MESS)
  293.      { case CALL_0:    ws("\tCALL: "); break;
  294.        case REDO_0:    ws("\tREDO: "); break;
  295.        case PROVED_0:  ws("\tEXIT: "); break;
  296.        case FAILED_0:  ws("\tFAIL: "); break;
  297.      }
  298.      QUOTE=true; DISPLFLAG=false; LISTFLAG=false; VARCNT=0; 
  299.      WRITETERM(Y,MAXPREC,20); 
  300.      QUOTE=false;
  301.      if( 1 /*MESS==CALL_0 || MESS==REDO_0*/)
  302.      {
  303.         mesg:
  304.            ws("   [sanft?\\n] "); 
  305.        nextch:
  306.   if(FILEENDED()) goto ret;
  307.          GETCHAR();
  308.   if(!mustread && (CH != '\n'))goto nextch;
  309.          switch(CH)
  310.          { 
  311.     case 's': case 'S':   TRACE_GOON=E; 
  312.                          mustread=false;
  313.                          goto nextch;
  314.     case 'a': case 'A':   TRACE_GOON=0;ABORT(ABORTE); 
  315.     case 'f': case 'F':  answer=false; 
  316.                          mustread=false;
  317.                          TRACE_GOON=0;
  318.                          goto nextch;
  319.     case 'n': case 'N':  TRACING=false;
  320.                          SPYTRACE=SPYING;
  321.                          TRACE_GOON=0;
  322.                          mustread=false;
  323.                          goto nextch;
  324.     case 't': case 'T':  TRACING=true;
  325.                          SPYTRACE=true;
  326.                          mustread=false;
  327.                          goto nextch;
  328.     case '0': case '1': case '2': case '3': case '4':
  329.     case '5': case '6': case '7': case '8': case '9':
  330.                          if(!newgo)TRACE_GOON=CH-'0';
  331.                          else
  332.                            TRACE_GOON=10*TRACE_GOON + CH-'0';
  333.                          if(TRACE_GOON >E)
  334.                           { TRACE_GOON=0; mustread=false;}
  335.                          break;
  336.     case '?':
  337.                          ws(" [s]kip\n");
  338.                          ws(" [a]bort\n");
  339.                          ws(" [n]otrace\n");
  340.                          ws(" [f]ail\n");
  341.                          ws(" [t]race\n");
  342.                          ws(" [\\n]  next");
  343.                          mustread=false;again=true;
  344.                          goto mesg;
  345.     case '\n':           if(!again) goto ret;            
  346.                          again=false;
  347.                          mustread=true;/* no break */
  348.     default:             goto nextch;
  349.          }
  350.      }
  351.      else ws("\n");
  352.     ret:
  353.     inputfile=OpenFile(oldinfile,read_mode);
  354.     outputfile=OpenFile(oldoutfile,write_mode);
  355.     return answer;
  356. }
  357.  
  358. GLOBAL void wq(ATOM A)
  359. {/* quoted output if necessary */
  360.     int nIDENT=0,aIDENT=0;
  361.     int notfirst=0;
  362.     string s,ss;
  363.     ss=s=tempcopy(A);
  364.     if(QUOTE==false) goto noquote; 
  365.     do {
  366.         switch(CHARCLASS[*s])
  367.         {
  368.             case BC:
  369.             case DC: if(!notfirst)goto quote;
  370.             case SC: ++nIDENT; break;
  371.             case OC: ++aIDENT;break;
  372.             default: goto quote;
  373.         }
  374.         s++;notfirst++;
  375.     }while(*s);
  376.   if(nIDENT &&  aIDENT) goto quote;
  377.  noquote:
  378.      ws(ss);
  379.      return;
  380.  quote: ws("\'");
  381.         while(*ss)
  382.         {
  383.             if(*ss== '\t') ws("\\t");
  384.             else if(*ss== '\n') ws("\\n");
  385.             else if(*ss== '\007') ws("\\a");
  386.             else if(*ss== '\r') ws("\\r");
  387.             else if(*ss== '\b') ws("\\b");
  388.             else if(*ss== '\f') ws("\\f");
  389.             else if(*ss== '\v') ws("\\v");
  390.             else if(*ss== '\\') ws("\\\\");
  391.             else if(*ss== '\'') ws("\'\'");
  392.             else if(*ss < ' ' || *ss > '~') 
  393.                 { ws("\\");
  394.                   wc((int)(((unsigned int)(*ss & 0300)) >> 6) + '0');
  395.                   wc((int)(((unsigned int)(*ss & 0070)) >> 3) + '0');
  396.                   wc((int)((unsigned int)(*ss & 0007)) + '0');
  397.                 }
  398.             else wc(*ss);
  399.             ss++;
  400.         }
  401.         ws("\'");
  402.         return;
  403. }
  404.  
  405.  
  406.